home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / cmpnew / make_ufun.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  3.2 KB  |  87 lines
  1. ;;; MAKE_UFUN  Makes Ufun list for user-defined functions.
  2. ;;;
  3. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  4.  
  5. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  6. ;;
  7. ;; GCL is free software; you can redistribute it and/or modify it under
  8. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11. ;; 
  12. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  13. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  15. ;; License for more details.
  16. ;; 
  17. ;; You should have received a copy of the GNU Library General Public License 
  18. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  19. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  
  22.  
  23. (in-package 'compiler)
  24.  
  25. (defvar gazonk (make-package 'symbol-table :use nil))
  26. (defvar eof (cons nil nil))
  27. (defvar *Ufun-out*)
  28.  
  29. (defvar *str* (make-array 128 :element-type 'string-char :fill-pointer 0))
  30.  
  31. (defun make-Ufun (in-files &key (out-file "Ufun_list.lsp"))
  32.   (with-open-file (*Ufun-out* out-file :direction :output)
  33.     (print '(in-package "COMPILER") *Ufun-out*)
  34.     (dolist (file in-files)
  35.       (with-open-file (in (merge-pathnames file #".lsp"))
  36.         (loop (when (eq (setq form (read in nil eof)) eof) (return))
  37.               (do-form form))))))
  38.  
  39. (defun do-form (form)
  40.     (when (consp form)
  41.         (case (car form)
  42.           (defun
  43.            (let ((*package* (find-package 'compiler)))
  44.                 (print `(si:putprop
  45.                          ',(cadr form)
  46.                          ,(get-cname (cadr form))
  47.                          'Ufun)
  48.                        *Ufun-out*))
  49.            (eval form))
  50.           (progn (mapc #'do-form (cdr form)))
  51.           (eval-when
  52.            (if (member 'load (cadr form))
  53.                (mapc #'do-form (cddr form))
  54.                (if (member 'compile (cadr form))
  55.                    (mapc #'eval (cddr form)))))
  56.           (t
  57.            (if (macro-function (car form))
  58.                (do-form (macroexpand-1 form))
  59.                (eval form))))))
  60.  
  61. (defun get-cname (symbol &aux (name (symbol-name symbol)))
  62.   (setf (fill-pointer *str*) 0)
  63.   (vector-push #\U *str*)
  64.   (dotimes (n (length name))
  65.            (let ((char (schar name n)))
  66.                 (cond ((alphanumericp char)
  67.                        (vector-push (char-downcase char) *str*))
  68.                       ((char= char #\-) (vector-push #\_ *str*))
  69.                       ((char= char #\*) (vector-push #\A *str*))
  70.                       )))
  71.   (multiple-value-bind (foo flag) (find-symbol *str* 'symbol-table)
  72.     (unless flag
  73.             ;(setq foo (intern (copy-seq *str*) 'symbol-table))
  74.             (setq foo (intern *str* 'symbol-table))
  75.             ;(set foo nil)
  76.             (return-from get-cname *str*))
  77.     (gensym *str*)
  78.     (gensym 0)
  79.     (loop
  80.      (setq name (symbol-name (gensym)))
  81.      (multiple-value-bind (foo flag1)
  82.                           (intern name 'symbol-table)
  83.                           (unless flag1
  84.                                   ;(set foo nil)
  85.                                   (return-from get-cname name)))))
  86.   )
  87.